SuperHack/SuperHack CD.bin/CODING/PASCAL/FPKPAS65.ZIP/SRCRTLDO.ZIP/SOURCE/RTL/DOS/HEAP.INC

Text File | 1996-07-23 | 7.1 KB | 249 lines

{****************************************************************************

                   Copyright (c) 1994,96 by Florian Klaempfl

 ****************************************************************************}

{****************************************************************************
               functions for heap management in the data segment
 ****************************************************************************}

    var
       { blocks : array[1..32] of pointer; }
       _memavail : longint;

    function memavail : longint;

      begin
         memavail:=_memavail;
      end;

    type
       pfreerecord = ^tfreerecord;

       tfreerecord = record
          next : pfreerecord;
          size : longint;
       end;

    function maxavail : longint;

      var
         hp : pfreerecord;

      begin
         maxavail:=heapend-heapptr;
         hp:=freelist;
         while assigned(hp) do
           begin
              if hp^.size>maxavail then
                maxavail:=hp^.size;
              hp:=hp^.next;
           end;
      end;

    procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];


      function call_heaperror(size : longint) : integer;
{$ifdef DOS}
        begin
           asm
              pushl 12(%ebp)
              movl U_SYSTEM_HEAPERROR,%eax
              call (%eax)
              leave
              ret $8
           end;
        end;
{$endif}
{$ifdef LINUX}
        begin
           asm
              pushl 12(%ebp)
              movl U_SYSLINUX_HEAPERROR,%eax
              call (%eax)
              leave
              ret $8
           end;
        end;
{$endif}

      var
         last,hp : pfreerecord;
         nochmal : boolean;

      begin
         if size=0 then
           begin
              p:=heapend;
              exit;
           end;
         { Auf Vielfaches von 8 Byte umrechnen }
         if (size mod 8)<>0 then
           size:=size+(8-(size mod 8));
         dec(_memavail,size);
         repeat
           nochmal:=false;
           { nun ist die freelist dran: }
           if assigned(freelist) then
             begin
                last:=nil;
                hp:=freelist;
                while assigned(hp) do
                  begin
                     { erster passender Block wird genommen }
                     if hp^.size>=size then
                       begin
                          p:=hp;
                          { wird der ganze Block benötigt ? }
                          if hp^.size>size then
                            begin
                               (hp+size)^.size:=hp^.size-size;
                               (hp+size)^.next:=hp^.next;
                               if assigned(last) then
                                 last^.next:=hp+size
                               else
                                 freelist:=hp+size;
                            end
                          else
                            begin
                               if assigned(last) then
                                 last^.next:=hp^.next
                               else
                                 freelist:=nil;
                            end;
                          exit;
                       end;
                     last:=hp;
                     hp:=hp^.next;
                  end;
             end;
           { zuletzt wird an der Heapspitze nachgeschaut, ob }
           { noch Speicher frei ist                          }
           if heapend-heapptr<size then
             begin
                if assigned(heaperror) then
                  begin
                     case call_heaperror(size) of
                        0 : runerror(203);
                        1 : p:=nil;
                        2 : nochmal:=true;
                     end;
                  end
                else
                  runerror(203);
             end
           else
             begin
                p:=heapptr;
                heapptr:=heapptr+size;
             end;
         until not nochmal;
      end;

    procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];

      var
         hp : pfreerecord;

      begin
         if (p<heaporg) or (p>heapptr) then
           begin
              writeln('pointer doesn''t points to the heap');
              halt;
           end;
         { Auf Vielfaches von 8 Byte umrechnen }
         if (size mod 8)<>0 then
           size:=size+(8-(size mod 8));
         inc(_memavail,size);
         if p+size>=heapptr then
           heapptr:=p
         else
           begin
              { size can be allways set }
              pfreerecord(p)^.size:=size;

              { if there is no free list }
              if not assigned(freelist) then
                begin
                   { then generate one }
                   freelist:=p;
                   pfreerecord(p)^.next:=nil;
                   p:=nil;
                   { we are ready }
                   exit;
                end;
              { an welcher Position der freelist einfügen? }
              hp:=freelist;
              while assigned(hp) do
                begin
                   { conneting two blocks ? }
                   if hp+hp^.size=p then
                      begin
                         inc(hp^.size,size);
                         break;
                      end
                   { if the end is reached, then concat }
                   else if hp^.next=nil then
                     begin
                        hp^.next:=p;
                        pfreerecord(p)^.next:=nil;
                        break;
                     end
                   { falls der nächste Zeiger größer ist, dann }
                   { Einhängen                                 }
                   else if hp^.next>p then
                     begin
                        { vielleicht zwei Blöcke zusammenfassen ? }
                        if p+size=hp^.next then
                          begin
                             pfreerecord(p)^.next:=hp^.next^.next;
                             inc(pfreerecord(p)^.size,hp^.next^.size);
                          end
                        else
                          begin
                             pfreerecord(p)^.next:=hp^.next;
                             hp^.next:=p;
                          end;
                        break;
                     end;
                   hp:=hp^.next;
                end;
           end;
         p:=nil;
      end;

    function getheapstart : pointer;

      begin
         asm
            leal HEAP,%eax
            leave
            ret
         end ['EAX'];
      end;

    function getheapsize : longint;

      begin
         asm
            movl HEAPSIZE,%eax
            leave
            ret
         end ['EAX'];
      end;

    procedure release(var p : pointer);

      begin
         heapptr:=p;
         freelist:=p;
      end;

    procedure mark(var p : pointer);

      begin
         p:=heapptr;
      end;